home *** CD-ROM | disk | FTP | other *** search
/ Shareware Extravaganza - Disc 4 / Shareware Extravaganza - Over 25,000 Programs (The Ultimate Shareware Company)(Disc 4 of 4)(1993).iso / cad / cmenu13.zip / CMENU.LSP < prev    next >
Lisp/Scheme  |  1990-08-26  |  4KB  |  146 lines
  1. ; Custom#Menu (c) 1990 Mountain Software
  2. ; 8/26/90 version 1.3
  3.  
  4. (princ "\nLoading CMenu...")
  5.  
  6. ;------
  7. Initialize variables
  8. ;------
  9.  
  10. (setq _typ    "Command"
  11.       _lstyp    _typ
  12.       _lblk    nil
  13.       _ttl    ""
  14.       _cmd    ""
  15. )
  16.  
  17. ;------
  18. ; Block insert routine
  19. ;------
  20.  
  21. (defun doinsert (/ _blk blkrec lstrec s)
  22.     (if (null _lblk) (progn
  23.     (setq blkrec (tblnext "BLOCK" T)          ;retrieve first block
  24.           lstrec blkrec)
  25.     (while (boundp 'blkrec)
  26.       (setq blkrec (tblnext "BLOCK"))
  27.       (if (boundp 'blkrec) (setq lstrec blkrec))
  28.     )
  29.     (if (boundp 'lstrec) (setq _lblk (cdr (assoc 2 lstrec))))
  30.     ))
  31.     (if (null _lblk) (progn
  32.       (initget 1)
  33.       (setq s "\nBlock name: ")
  34.     )
  35.     (progn
  36.       (setq s (strcat "\nBlock name[" _lblk "]:"))
  37.       (if (null s) (setq s _lblk))
  38.     ))
  39.     (setq _blk (getstring s))
  40.     (if (not _blk) (setq _blk _lblk))
  41.     (if (boundp '_blk) (setq _cmd _blk) (setq _cmd nil))
  42. )
  43.  
  44. ;------
  45. ; Command input function
  46. ;------
  47.  
  48. (defun docommand ()
  49.     (princ "\nSpecial Menu Command Characters:")
  50.     (princ "\n^C^C = Cancel, ^P = Toggle menuecho, ; = Return, \\ = Pause for input")
  51.     (setq _cmd (getstring t "\nEnter menu command: "))
  52. )
  53.  
  54. ;------
  55. ; AutoLisp function
  56. ;------
  57.  
  58. (defun dolisp (/ al_fn al_cmd)
  59.     (setq al_fn  (getstring "\nAutolisp filename: ")
  60.       al_cmd (getstring (strcat "\nAutolisp command to execute[" al_fn "]: ")))
  61.     (if (= al_cmd "") (setq al_cmd al_fn))
  62.     (if (= al_fn "") (setq _cmd al_cmd) ;else
  63.       (setq _cmd (strcat "^C^C^P(cond ((null c:" al_cmd ") (load \""
  64.                           al_fn "\")) (t (princ))) " al_cmd " ^P"))
  65.     )
  66. )
  67.  
  68. ;------
  69. ; Write Parameter file
  70. ;------
  71.  
  72. (defun writedat (/ f)
  73.     (setq f (open "cmenu.dat" "w"))
  74.     (if (boundp 'f) (progn
  75.     (princ (strcat (getvar "MENUNAME") "\n") f)
  76.     (princ (strcat (getvar "DWGPREFIX") "\n") f)
  77.     (princ (strcat (getvar "ACADPREFIX") "\n") f)
  78.     (princ (strcat _ttl "\n") f)
  79.     (princ mode f) (princ "\n" f)
  80.     (princ item f) (princ "\n" f)
  81.     (princ (strcat insovr "\n") f)
  82.     (princ (strcat _typ "\n") f)
  83.     (princ (strcat _cmd "\n") f)
  84.     (close f)
  85.   ) (princ "\nError opening CMENU.DAT"))
  86. )
  87.  
  88. ;------
  89. ; Main
  90. ;------
  91.  
  92. (defun c:cmenu (/ cecho trk done)
  93.   (setq cecho    (getvar "CMDECHO"))
  94.   (setvar "CMDECHO" 0)
  95.   (princ "\nCMenu initializing...")
  96.   (command "MENU" "")
  97.   (graphscr)
  98.   (princ "\n\n\nPick Tablet, Button or Screen Menu Location with cursor...")
  99.   (setq trk    (grread)
  100.     mode    (car trk)
  101.     item    (cadr trk)
  102.     done    nil
  103.   )
  104.   (cond ((= mode 4)
  105.         (if (< item 1000)    (princ "\nScreen Menu selected ") ;else
  106.                 (princ "\nPopUp Menu selected "))
  107.     )
  108.     ((= mode 6) (princ "\nButtons selected "))
  109.     ((= mode 7) (princ "\nTABLET1 selected "))
  110.     ((= mode 8) (princ "\nTABLET2 selected "))
  111.     ((= mode 9) (princ "\nTABLET3 selected "))
  112.     ((= mode 10) (princ "\nTABLET4 selected "))
  113.     ((= mode 11) (princ "\nAUX1 selected "))
  114.     ((= mode 13) (princ "\nKeyboard Menu selected "))
  115.     (t  (setq done t))
  116.   )
  117.   (if (not done) (progn
  118.     (if (and (>= mode 6) (<= mode 11)) (setq insovr "Overwrite") (progn ;else
  119.       (initget 0 "Add Insert Overwrite Delete")
  120.       (setq insovr (getkword (strcat "\nAdd/Insert/Overwrite/Delete[I]: ")))
  121.       (if (null insovr) (setq insovr "Insert"))
  122.     ))
  123.     (if (/= insovr "Delete") (progn
  124.       (princ "\nSpecial Titles:\n ~-- = Horizontal line in PopUp, Blank title = Command used for title")
  125.       (setq _ttl (getstring t "\nEnter Menu Title: "))
  126.       (initget 0 "AutoLisp Insert Command")
  127.       (setq _lstyp _typ)
  128.       (setq _typ (getkword (strcat "\nAutoLisp/Insert block/Command[" _lstyp "]: ")))
  129.       (if (null _typ) (setq _typ _lstyp))
  130.       (if (= _typ "Insert") (doinsert)
  131.     (if (= _typ "AutoLisp") (dolisp)
  132.         (docommand)
  133.     )
  134.       )
  135.     ))
  136.     (writedat)
  137.     (command "SHELL" "CMENU")
  138.     (setvar "CMDECHO" 1)
  139.     (command "MENU" "")
  140.   ))
  141.   (setvar "CMDECHO" cecho)
  142.   (princ)
  143. )
  144. (princ "\nCMenu loaded - Enter \"CMENU\" to run") (princ)
  145.  
  146.